home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / Generalized LISP / Glisp 1.2 / Object files / Scanner.lisp < prev   
Encoding:
Text File  |  1990-08-20  |  4.9 KB  |  49 lines  |  [TEXT/CCL ]
  1.  
  2. (export (quote (! @ \# $ % ^ & * \( \) _ + - = { } [ ] \: \" \; \' < > ? \, \. / ~ \` \| \\ \:= <= >= /= \¡ \™ \£ \¢ \∞ \§ \¶ \• \ª \º \– \≠ \∑ \´ \® \† \¥ \¨ ^ \π \“ \‘ \∂ \ƒ \© \Δ \¬ \… \Ω \≈ \√ \∫ \µ \≤ \≥ \÷ \« \° \— \± \∏ \” \’ \ \◊ \¿ \» \æ \œ \ç \ø \å \ß \Æ \Œ \Ç \Ø \Å)) :glisp) 
  3.  
  4. (proclaim (quote (special *lisp-readtable*))) 
  5.  
  6. (proclaim (quote (special *glisp-readtable*))) 
  7.  
  8. (proclaim (quote (special *glisp-sexp-readtable*))) 
  9.  
  10. nil 
  11.  
  12. (setf *lisp-readtable* *readtable*) 
  13.  
  14. (setf *glisp-readtable* (copy-readtable nil)) 
  15.  
  16. (do (c (&c& (quote (! ? _ & \æ \œ \ç \ø \å \ß \Æ \Œ \Ç \Ø \Å)) (cdr &c&)) glisp::&v) ((atom &c&) glisp::&v) (setq c (car &c&)) (setq glisp::&v (set-syntax-from-char (character c) #\z *glisp-readtable* *lisp-readtable*))) 
  17.  
  18. (do (c (&c& (quote (@ \# $ % ^ * \( \) + - = { } [ ] \: \" \; \' < > \, \. / ~ \` \| \\ \¡ \™ \£ \¢ \∞ \§ \¶ \• \ª \º \– \≠ \∑ \´ \® \† \¥ \¨ ^ \π \“ \‘ \∂ \ƒ \© \Δ \¬ \… \Ω \≈ \√ \∫ \µ \≤ \≥ \÷ \« \° \— \± \∏ \” \’ \ \◊ \¿ \»)) (cdr &c&)) glisp::&v) ((atom &c&) glisp::&v) (setq c (car &c&)) (setq glisp::&v (prog nil (setf (get c (quote delimiter)) t) (cond ((member c (quote (\" ~ \` \\))) (return nil))) (set-syntax-from-char (character c) #\, *glisp-readtable* *lisp-readtable*) (eval (list (quote set-macro-character) (character c) (cons (quote function) (list (cons (quote lambda) (cons (quote (stream char)) (list (cons (quote quote) (list c))))))) nil *glisp-readtable*))))) 
  19.  
  20. (do (c (&c& (list !eof (quote \:=) (quote <=) (quote >=) (quote /=)) (cdr &c&)) glisp::&v) ((atom &c&) glisp::&v) (setq c (car &c&)) (setq glisp::&v (setf (get c (quote delimiter)) t))) 
  21.  
  22. (set-dispatch-macro-character #\# #\$ (function (lambda (stream char x) (list (quote veval) (pvariable (read stream nil !eof t) t)))) *lisp-readtable*) 
  23.  
  24. (set-syntax-from-char #\~ #\; *glisp-readtable* *lisp-readtable*) 
  25.  
  26. (set-macro-character #\` (function (lambda (stream x) (prog nil (unread-char #\` stream) (setf x (lispread stream nil !eof nil)) (cond ((and (consp x) (eq (car x) (quote quote)) (consp (cdr x)) (null (cddr x))) (setf x (cadr x)))) (return x)))) nil *glisp-readtable*) 
  27.  
  28. (set-macro-character #\: (function (lambda (stream char) (cond ((char= (peek-char nil stream nil !eofchar t) #\=) (read-char stream nil !eofchar t) (quote \:=)) (t (quote \:))))) nil *glisp-readtable*) 
  29.  
  30. (set-macro-character #\< (function (lambda (stream char) (cond ((char= (peek-char nil stream nil !eofchar t) #\=) (read-char stream nil !eofchar t) (quote <=)) (t (quote <))))) nil *glisp-readtable*) 
  31.  
  32. (set-macro-character #\> (function (lambda (stream char) (cond ((char= (peek-char nil stream nil !eofchar t) #\=) (read-char stream nil !eofchar t) (quote >=)) (t (quote >))))) nil *glisp-readtable*) 
  33.  
  34. (set-macro-character #\/ (function (lambda (stream char) (cond ((char= (peek-char nil stream nil !eofchar t) #\=) (read-char stream nil !eofchar t) (quote /=)) (t (quote /))))) nil *glisp-readtable*) 
  35.  
  36. (set-macro-character #\^ (function (lambda (stream char) (quote expt))) nil *glisp-readtable*) 
  37.  
  38. (setf *glisp-sexp-readtable* (copy-readtable *glisp-readtable*)) 
  39.  
  40. (set-syntax-from-char #\( #\( *glisp-sexp-readtable* *lisp-readtable*) 
  41.  
  42. (set-macro-character #\( (get-macro-character #\( *lisp-readtable*) nil *glisp-sexp-readtable*) 
  43.  
  44. (do (sym (&sym& (quote (+ - * / and or append nconc = /= < <= > >= char< char<= char> char>= char= char-equal char-lessp char-greaterp char/= char-not-equal char-not-lessp char-not-greaterp string< string<= string> string>= string= string-equal string-lessp string-greaterp string/= string-not-equal string-not-lessp string-not-greaterp)) (cdr &sym&)) glisp::&v) ((atom &sym&) glisp::&v) (setq sym (car &sym&)) (setq glisp::&v (setf (get sym (quote associative)) t))) 
  45.  
  46. (do (sym (&sym& (quote (+ - not null atom eval go car caaaar first cdr caaadr second caar caadar third cadr caaddr fourth cdar cadaar fifth cddr cadadr sixth caaar caddar seventh caadr cadddr eight cadar cdaaar ninth caddr cdaadr tenth cdaar cdadar rest cdadr cdaddr cddar cddaar cdddr cddadr cdddar cddddr)) (cdr &sym&)) glisp::&v) ((atom &sym&) glisp::&v) (setq sym (car &sym&)) (setq glisp::&v (setf (get sym (quote prefix)) t))) 
  47.  
  48. (do (l (&l& (quote ((1001 0 \:= set setq setf psetq) (800 850 expt) (700 750 * /) (600 650 + -) (500 550 default) (450 400 cons append revappend nconc nreconc cat concatenate) (300 350 = eq eql equal equalp /= neq neql nequal nequalp < <= > >= char< char<= char> char>= char= char-equal char-lessp char-greaterp char/= char-not-equal char-not-lessp char-not-greaterp string< string<= string> string>= string= string-equal string-lessp string-greaterp string/= string-not-equal string-not-lessp string-not-greaterp) (200 250 and) (100 150 or))) (cdr &l&)) glisp::&v) ((atom &l&) glisp::&v) (setq l (car &l&)) (setq glisp::&v (do (sym (&sym& (cddr l) (cdr &sym&)) glisp::&v) ((atom &sym&) glisp::&v) (setq sym (car &sym&)) (setq glisp::&v (progn (setf (get sym (quote left)) (first l)) (setf (get sym (quote right)) (second l))))))) 
  49.